home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Languages Suite
/
ProgLangD.iso
/
TURBOPASCAL WIN
/
OWLDEMOS.PAK
/
OLEOBJ.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-06-08
|
23KB
|
725 lines
{***************************************************}
{ }
{ Turbo Pascal for Windows }
{ Windows 3.1 OLE Server Demonstration Program }
{ OLE Object Unit }
{ }
{ Copyright (c) 1992 by Borland International }
{ }
{***************************************************}
{ This unit implements the actual OLE Object. The Object rep-
resents the lowest level of interaction between the Client and
Server: the Object is the actual information the Client is after.
For this demo, the only supported object is a simple blue graphic
that can be one of three shapes: a circle, a square, or a
rectangle.
Although we have embedded the native data in the ole object, you might
not want to do this. Rather than integrate OLE with your app you
should treat OLE as a protocol that sits on top of your app and allows
other applications access to your server's data. Instead of embedding
the data in the OLE object have the OLE object contain a pointer to the
native data.
Note: To compile the OLE Server demo, set Compile|Primary File to OLESERVR.PAS
}
unit OleObj;
interface
uses WinTypes, WObjects, Ole, OleTypes;
type
{ Type which defines the types of actions that the server can perform on
an object.
}
TVerb = (VerbEdit, VerbPlay);
{ The following record types represent the Object within
the OLE library. It is based on the standard structure
defined in Ole.pas, and adds one field to provide access
back to the TPW object which represents it.
}
POleObjectObj = ^TOleObjectObj;
PAppObject = ^TAppObject;
TAppObject = record
OleObject: TOleObject;
Owner : POleObjectObj;
end;
{ TOleObjectObj }
{ This object represents the OLE Object, wrapping useful
behaviors around the basic TOleObject structure that is
used within OLE to represent an object. This structure
is represented by the AppObject data field, which is of
the TAppObject type defined in oleservr.pas, and which
includes an additional field which points back to Self
so that our callback functions can reference this object.
}
TOleObjectObj = object(TObject)
AppObject : TAppObject;
Native : TNative;
IsReleased: Boolean; { True if Release method has been called }
Clients : array[0..MaxLinks] of POleClient; { nil terminated list of client(s) }
{ we are linked to }
constructor Init;
constructor Load(var S: TStream);
procedure AddClientLink(OleClient: POleClient); virtual;
procedure Draw(ADC: HDC); virtual;
function GetType: TNativeType; virtual;
procedure ObjectChanged; virtual;
procedure SetType(NewType: TNativeType); virtual;
procedure Store(var S: TStream); virtual;
{ Routines to build the various clipboard formats that are required for
an OLE server. Your routine might provide routines for additional
formats such as TEXT, RTF, and DIB.
}
function GetNativeData: THandle; virtual;
function GetLinkData: THandle; virtual;
function GetBitmapData: HBitmap; virtual;
function GetMetafilePicture: THandle; virtual;
end;
{ TOleObjectObj stream registration record }
const
ROleObjectObj: TStreamRec = (
ObjType: 888;
VmtLink: Ofs(TypeOf(TOleObjectObj)^);
Load : @TOleObjectObj.Load;
Store : @TOleObjectObj.Store
);
function TOleObjectObj_InitVTBL(Inst: THandle): Boolean;
implementation
uses WinProcs, Strings, Server, OleApp, ServrWin;
{ Global variables }
var
OleObjectVtbl: TOleObjectVtbl;
{ Object Callback Procedures }
{ NOTE:
The first parameter to each callback is a pointer to the TOleObject
structure that defines this object. In each case, we know that it
will really be a pointer to a TAppObject record, which includes a
pointer to the Pascal object which owns the TOleObject record. We
can therefore use a typecast to access that object, and thus find our
way back to Self.
}
{ Handles the QueryProtocol callback. The server library is trying to
determine which protocols we support. 'Protocol' will either be
'StdFileEditing' or 'StdExecute'. If we don't support the protocol
then we should return nil. Since we don't support 'StdFileExecute'
we return nil in that case.
}
function QueryProtocol(Self: POleObject; Protocol: PChar): Pointer; export;
begin
if StrIComp(Protocol, 'StdFileEditing') = 0 then
QueryProtocol := Self
else
QueryProtocol := nil;
end;
{ Handles the Release callback. This gets called when the library wants
to inform us that we have no more clients connected to the object. It
is initiated after the client calls OleDelete or the server calls
OleRevokeServer, OleRevokeServerDoc, or OleRevokeObject.
This is the last time that the receiving object will be called, so all
resources for the object can be free'd, but we MUST not delete the object
itself.
WHAT TO DO:
- Free resources associated with the object
- Set a flag to indicate 'Release' has been called
- Nil out any POleClient handles saved in the object
- Return ole_Ok if successful, Ole_Error_Generic otherwise
NOTE: This is not called Release since it appears at the same scope as
the Release callback for the Server.
}
function ReleaseObj(Self: POleObject): TOleStatus; export;
var
SelfPtr: POleObjectObj;
begin
SelfPtr := PAppObject(Self)^.Owner;
SelfPtr^.Clients[0] := nil;
SelfPtr^.IsReleased := True;
ReleaseObj := ole_Ok;
end;
{ Handles the Show callback. This gets called when we should make the
object visible by making the server window visible and possibly scroling
the object into view. If the object is selectable, select it as well.
'TakeFocus' indicates whether the server should set focus to itself.
WHAT TO DO:
- Show the window(s) if not visible
- Scroll 'OleObject' into view and select it if possible
- If 'TakeFocus' is True, call SetFocus with the main window handle
- Return ole_Ok if successful, Ole_Error_Generic otherwise
}
function Show(Self: POleObject; TakeFocus: Bool): TOleStatus; export;
begin
{ In our case all we need to do is request that the window is showing
}
Application^.MainWindow^.Show(sw_ShowNormal);
if TakeFocus then
SetFocus(Application^.MainWindow^.HWindow);
Show := ole_Ok;
end;
{ Handles the DoVerb callback. The client application has called
OleActivate on an embedded object and requests an action on the object.
The action is specified by the verb identifier 'Verb'. This server
only understands EDIT and PLAY: all we do for PLAY is beep, and for
EDIT we bring up the server and let the user edit the specified object.
PARAMETERS:
- 'Verb' is the index to the verb to execute
- 'Show' indicates if the server should show the object or
remain in its current state
- 'Focus' indicates if the server should take the focus
WHAT TO DO:
- For PLAY verb, a server doesn't usually show its window or affect the
focus
- For EDIT verb, show the server's window and object if 'Show' and
take the focus if 'Focus'
- Return ole_Ok if successful, Ole_Error_DoVerb otherwise
}
function DoVerb(Self: POleObject; Verb: Word; Show, Focus: Bool): TOleStatus; export;
begin
case TVerb(Verb) of
VerbEdit:
{ The easiest way to show the server's window is to send the
object a 'Show' message. Note how we access the Object's
callback list directly.
}
if Show then
DoVerb := Self^.lpvtbl^.Show(Self, Focus)
else
DoVerb := ole_Ok;
VerbPlay:
begin
MessageBeep(0);
MessageBeep(0);
DoVerb := ole_Ok;
end;
else
DoVerb := Ole_Error_DoVerb;
end;
end;
{ Handles the GetData callback. We are requested to supply data for
the object in a specific format, such as Native or cf_MetaFilePict.
In general, you should handle the same data formats that you put on
the clipboard when the object was embedded/linked. These should be
the same formats that are returned by EnumFormats callback.
Requests for GetData occur any time that the client needs to display
an object, or when the data must be written to a client file.
}
function GetData(Self: POleObject; Format: TOleClipFormat;
var Handle: THandle): TOleStatus; export;
var
App : POleApp;
Stat : TOleStatus;
SelfPtr: POleObjectObj;
begin
SelfPtr:= PAppObject(Self)^.Owner;
App := POleApp(Application);
Stat := ole_Ok;
if Format = App^.cfNative then
Handle := SelfPtr^.GetNativeData
else
if Format = App^.cfOwnerLink then
Handle := SelfPtr^.GetLinkData
else
if Format = cf_Bitmap then
Handle := SelfPtr^.GetBitmapData
else
if Format = cf_MetaFilePict then
Handle := SelfPtr^.GetMetafilePicture
else
Stat := Ole_Error_Format;
if Stat = ole_Ok then
if Handle = 0 then
Stat := Ole_Error_Memory;
GetData := Stat;
end;
{ Handles the SetData callback. This gets called to provide the server
with the data for an object that is embedded in a client. This routine
gets called after the server has received an 'Edit' message. This is
always called before 'DoVerb' and 'Show'.
WHAT TO DO:
- If the data format isn't supported, return Ole_Error_Format
- Lock down the memory to get a pointer to the data, returning
Ole_Error_Memory if GlobalLock returns NULL
- Copy the data to the object indicated by 'Self'
- Unlock the memory and call GlobalFree on the handle (you are
responsible for the memory!)
- Return ole_Ok
}
function SetData(Self: POleObject; Format: TOleClipFormat;
Data: THandle): TOleStatus; export;
var
App : POleApp;
SelfPtr: POleObjectObj;
DataPtr: PNative;
begin
SelfPtr:= PAppObject(Self)^.Owner;
App := POleApp(Application);
if Format <> App^.cfNative then
SetData := Ole_Error_Format { Data isn't in Native format }
else
begin
DataPtr := PNative(GlobalLock(Data));
if DataPtr = nil then
SetData := Ole_Error_Memory
else
begin
SelfPtr^.Native := DataPtr^;
GlobalUnlock(Data);
GlobalFree(Data);
SetData := ole_Ok;
end;
end;
end;
{ Handles the SetTargetDevice callback. Not supported; always returns
Ole_Error_Generic.
}
function SetTargetDevice(Self: POleObject;
TargetDevice: THandle): TOleStatus; export;
begin
SetTargetDevice := Ole_Error_Generic;
end;
{ Handles the SetBounds callback. Not supported; always returns
Ole_Error_Generic.
}
function SetBounds(Self: POleObject; var Bounds: TRect): TOleStatus; export;
begin
SetBounds := Ole_Error_Generic;
end;
{ Handles the EnumFormats callback. The client has requested that we
enumerate all clipboard formats that we support for the object 'Self'.
The server library will make multiple calls until we return the format
that the server library is looking for
PARAMETERS:
- 'Format' is the last format returned by this method. if it is 0 then
this is the first call to the method for this series
We terminate the query by returning NULL.
NOTE: We *must* return the formats in the same order as the order that
data is placed on the clipboard!
}
function EnumFormats(Self: POleObject;
Format: TOleClipFormat): TOleClipFormat; export;
var
App : POleApp;
SelfPtr: POleObjectObj;
begin
App := POleApp(Application);
{ If 'Format' is 0 that indicates the client wants us to return the
first format
}
if Format = 0 then
EnumFormats := App^.cfNative
else
if Format = App^.cfNative then
EnumFormats := App^.cfOwnerLink
else
if Format = App^.cfOwnerLink then
EnumFormats := cf_MetaFilePict
else
if Format = cf_MetaFilePict then
EnumFormats := cf_Bitmap
else
EnumFormats := 0;
end;
{ Handles the SetColorScheme callback. Not supported, always returns
Ole_Error_Generic.
}
function SetColorScheme(Self: POleObject;
var Palette: TLogPalette): TOleStatus; export;
begin
SetColorScheme := Ole_Error_Generic;
end;
{ TOleObjectObj Methods }
{ Constructs an instance of the TOleObjectObj.
}
constructor TOleObjectObj.Init;
begin
AppObject.OleObject.lpvtbl := @OleObjectVTbl;
AppObject.Owner := @Self;
Native.NativeType:= ObjEllipse;
Native.Version := 1;
Clients[0] := nil;
IsReleased := False;
end;
{ Constructs the Ole Object by loading it from the given stream.
}
constructor TOleObjectObj.Load(var S: TStream);
var
NewType: TNativeType;
begin
AppObject.OleObject.lpvtbl := @OleObjectVTbl;
AppObject.Owner := @Self;
Native.NativeType:= ObjEllipse;
Native.Version := 1;
Clients[0] := nil;
IsReleased := False;
S.Read(NewType, SizeOf(NewType));
PServerWindow(Application^.MainWindow)^.ShapeChange(NewType);
Native.NativeType := TNativeType(NewType);
S.Read(Native.Version, SizeOf(Native.Version));
end;
{ Stores the Ole Object onto the given stream.
}
procedure TOleObjectObj.Store(var S: TStream);
begin
S.Write(Native.NativeType, SizeOf(Native.NativeType));
S.Write(Native.Version, SizeOf(Native.Version));
end;
{ Gets the 'NativeType' field of the Native instance variable
and returns it.
}
function TOleObjectObj.GetType: TNativeType;
begin
GetType := Native.NativeType;
end;
{ Sets the 'NativeType' field of the Native instance variable and calls
ObjectChanged to register the change.
}
procedure TOleObjectObj.SetType(NewType: TNativeType);
begin
Native.NativeType := NewType;
ObjectChanged;
end;
{ Responds to changes in a linked object by sending each of the clients
we are linked to an Ole_Changed message.
}
procedure TOleObjectObj.ObjectChanged;
var
I: Integer;
begin
{ Call the object through its callback function
}
I := 0;
while Clients[I] <> nil do
begin
Clients[I]^.lpvtbl^.CallBack(Clients[I], Ole_Changed, @AppObject);
inc(I);
end;
{ Mark the document as changed
}
POleApp(Application)^.Server^.Document^.IsDirty := True;
end;
{ Adds a link to another client.
}
procedure TOleObjectObj.AddClientLink(OleClient: POleClient);
var
I: Integer;
begin
{ We always append clients to the end of the list
}
I := 0;
while (Clients[I] <> nil) and (I < MaxLinks-1) do
inc(I);
if (Clients[I] = nil) then
begin
Clients[I] := OleClient;
Clients[I+1]:= nil; { Terminator }
end;
end;
{ Draws the type specified by the 'NativeType' field of 'Native' using the
device context that is passed in.
}
procedure TOleObjectObj.Draw(ADC: HDC);
const
Pts: array [0..3] of TPoint = ((X:ObjWidth div 2; Y:0),
(X:0; Y:ObjHeight - 1),
(X:ObjWidth - 1; Y:ObjHeight - 1),
(X:ObjWidth div 2; Y:0)
);
var
OldBrush : HBrush;
OldPen : HPen;
begin
OldBrush:= SelectObject(ADC, CreateSolidBrush(RGB(0, 0, 255)));
OldPen := SelectObject(ADC, GetStockObject(Null_Pen));
case Native.NativeType of
ObjEllipse:
Ellipse(ADC, 0, 0, ObjWidth, ObjHeight);
ObjRect:
Rectangle(ADC, 0, 0, ObjWidth, ObjHeight);
ObjTriangle:
Polygon(ADC, Pts, 4);
end;
DeleteObject(SelectObject(ADC, OldBrush));
SelectObject(ADC, OldPen);
end;
{ Returns a global memory handle that contains the native data for the
receiver. This handle can be used to set the Native clipboard data
format.
}
function TOleObjectObj.GetNativeData: THandle;
var
DataHdl : THandle;
DataPtr : PNative;
begin
DataHdl := GlobalAlloc(gmem_DdeShare, SizeOf(Native));
if DataHdl <> 0 then
begin
DataPtr := PNative(GlobalLock(DataHdl));
DataPtr^:= Native;
GlobalUnlock(DataHdl);
end;
GetNativeData := DataHdl;
end;
{ Returns a global memory handle suitable for pasting to the clipboard
that contains three fields:
- Class name
- Document name (typically a fully qualified path name that identifies
the file containing the document)
- Item name (uniquely identifies the part of the document that is defined
as an object)
The class name and document name are null terminated, and the item name
has two terminating null characters, e.g. CNAME#0DNAME#0INAME#0#0
NOTE: Item names are assigned by the server. Since we have only 1 object
per document, we always use the same name ('1'). most applications
would use a different strategy, e.g. 'Object1', 'Object2', etc.
Since 'ObjectLink' and 'OwnerLink' formats contain the same information
the handle that is returned can be used for both clipboard formats
}
function TOleObjectObj.GetLinkData: THandle;
var
DataHdl: THandle;
DataPtr: PChar;
Doc : POleDocument;
DocNameLen, ClassKeyLen, Len: Integer;
begin
Doc := POleApp(Application)^.Server^.Document;
DocNameLen := StrLen(Doc^.Name);
ClassKeyLen:= StrLen(ClassKey);
Len := ClassKeyLen + DocNameLen + StrLen('1') + 4; { 4 nulls }
DataHdl := GlobalAlloc(gmem_DdeShare, Len);
if DataHdl <> 0 then
begin
DataPtr := GlobalLock(DataHdl);
{ Write class name, then the doc name, and then the item name (always
'1'). Then, append the final NUL.
}
StrCopy(DataPtr, ClassKey);
DataPtr := DataPtr + ClassKeyLen + 1;
StrCopy(DataPtr, Doc^.Name);
DataPtr := DataPtr + DocNameLen + 1;
StrCopy(DataPtr, '1');
DataPtr[2] := #0;
GlobalUnlock(DataHdl);
end;
GetLinkData := DataHdl;
end;
{ Converts a width and height from device units to mm_HiMetric units,
which are required by the OLE libraries
}
procedure SizeToHiMetric(var Width, Height: Integer);
const
HiMetricPerInch : Longint = 2540;
var
ADC: HDC;
DpiX, DpiY: Integer;
begin
ADC := GetDC(0); { Gets a screen DC }
DpiX := GetDeviceCaps(ADC, LogPixelsX);
DpiY := GetDeviceCaps(ADC, LogPixelsY);
Width := round(Width * HiMetricPerInch / DpiX);
Height:= round(Height * HiMetricPerInch / DpiY);
ReleaseDC (0, ADC);
end;
{ Creates and returns a Metafile Pict which represents the current
object.
}
function TOleObjectObj.GetMetafilePicture: THandle;
var
PictPtr: PMetaFilePict;
PictHdl: THandle;
MFHdl : THandle;
ADC : HDC;
Width : Integer;
Height : Integer;
begin
ADC := CreateMetaFile(nil);
Width := 100;
Height:= 100;
{ Draw the object into the metafile
}
SetWindowOrg(ADC, 0, 0);
SetWindowExt(ADC, Width, Height);
Draw(ADC);
{ Get the handle to the metafile.
}
MFHdl := CloseMetaFile(ADC);
{ Allocate the metafile picture
}
PictHdl := GlobalAlloc(gmem_DDEShare, SizeOf(TMetaFilePict));
if PictHdl <> 0 then
begin
SizeToHiMetric(Width, Height);
PictPtr := PMetaFilePict(GlobalLock(PictHdl));
PictPtr^.mm := mm_Anisotropic;
PictPtr^.hMF := MFHdl;
PictPtr^.xExt := Width;
PictPtr^.yExt := Height;
GlobalUnlock(PictHdl);
end;
GetMetafilePicture := PictHdl;
end;
{ Creates and returns an image of the Object as a Bitmap.
}
function TOleObjectObj.GetBitmapData: HBitmap;
var
AWnd : HWnd;
ADC : HDC;
AMemDC : HDC;
ABitmap : HBitmap;
OldBitmap : HBitmap;
Width : Integer;
Height : Integer;
begin
AWnd := Application^.MainWindow^.HWindow;
ADC := GetDC(AWnd);
AMemDC:= CreateCompatibleDC(ADC);
ABitmap := CreateCompatibleBitmap(ADC, 100, 100);
OldBitmap := SelectObject(AMemDC, ABitmap);
Width := 100;
Height:= 100;
ReleaseDC(AWnd, ADC);
PatBlt(AMemDC, 0, 0, Width, Height, Whiteness);
Draw(AMemDC);
SelectObject(AMemDC, OldBitmap);
DeleteDC(AMemDC);
{ Convert the width and height to mm_Himetric (all OLE libraries express
the size of every object in mm_Himetric)
}
SizeToHiMetric(Width, Height);
{ SetBitmapDimension wants the width and height in .1 millimeter
units, so we must divide by 10.
}
SetBitmapDimension(ABitmap, round(Width / 10), round(Height / 10));
GetBitmapData := ABitmap;
end;
{ Initialize the VTbl for the Server. Create thunks for OleObjectObj callback
tables.
}
function TOleObjectObj_InitVTBL(Inst: THandle): Boolean;
begin
@OleObjectVTbl.QueryProtocol := MakeProcInstance(@QueryProtocol, Inst);
@OleObjectVTbl.Release := MakeProcInstance(@ReleaseObj, Inst);
@OleObjectVTbl.Show := MakeProcInstance(@Show, Inst);
@OleObjectVTbl.DoVerb := MakeProcInstance(@DoVerb, Inst);
@OleObjectVTbl.GetData := MakeProcInstance(@GetData, Inst);
@OleObjectVTbl.SetData := MakeProcInstance(@SetData, Inst);
@OleObjectVTbl.SetTargetDevice := MakeProcInstance(@SetTargetDevice, Inst);
@OleObjectVTbl.SetBounds := MakeProcInstance(@SetBounds, Inst);
@OleObjectVTbl.EnumFormats := MakeProcInstance(@EnumFormats, Inst);
@OleObjectVTbl.SetColorScheme := MakeProcInstance(@SetColorScheme, Inst);
TOleObjectObj_InitVTbl := (@OleObjectVTbl.QueryProtocol <> nil) and
(@OleObjectVTbl.Release <> nil) and
(@OleObjectVTbl.Show <> nil) and
(@OleObjectVTbl.DoVerb <> nil) and
(@OleObjectVTbl.GetData <> nil) and
(@OleObjectVTbl.SetData <> nil) and
(@OleObjectVTbl.SetTargetDevice <> nil) and
(@OleObjectVTbl.SetBounds <> nil) and
(@OleObjectVTbl.EnumFormats <> nil) and
(@OleObjectVTbl.SetColorScheme <> nil);
end;
end.